home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / pty.scm < prev    next >
Text File  |  1995-10-28  |  4KB  |  103 lines
  1. ;;; Pseudo terminals
  2. ;;; Copyright (c) 1995 by Olin Shivers.
  3.  
  4. ;;; (fork-pty-session thunk)
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6. ;;; Fork the process with stdio (fd's 0, 1, & 2 and also the current i/o ports)
  7. ;;; bound to a tty device. In the parent process, returns four values:
  8. ;;;     [process pty-inport pty-outport ttyname]
  9. ;;; - PROCESS is a process object for the child.
  10. ;;; - PTY-{IN,OUT}PORT are input and output ports open on the controlling pty
  11. ;;;   device. PTY-OUTPORT is unbuffered.
  12. ;;; - TTYNAME is the name of the child's tty, e.g. "/dev/ttyk4".
  13. ;;; 
  14. ;;; The subprocess is placed in its own session, and the tty device
  15. ;;; becomes the control tty for the new session/process-group/process. 
  16. ;;; The child runs with stio hooked up to the tty; the (error-output-port)
  17. ;;; port is unbuffered.
  18.  
  19. (define (fork-pty-session thunk)
  20.   (receive (pty-in ttyname) (open-pty)
  21.     (let* ((process (fork (lambda ()
  22.                 (close-input-port pty-in)
  23.                 (become-session-leader)
  24.                 (let ((tty (open-control-tty ttyname)))
  25.                   (move->fdes   tty 0)
  26.                   (dup->outport tty 1)
  27.                   (set-port-buffering (dup->outport tty 2)
  28.                           bufpol/none))
  29.                 (with-stdio-ports* thunk))))
  30.        (pty-out (dup->outport pty-in)))
  31.  
  32.       (set-port-buffering pty-out bufpol/none)
  33.       (values process pty-in pty-out ttyname))))
  34.  
  35. ;;; (open-pty)
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;; Returns two values: [pty-inport ttyname]
  38. ;;; PTY-PORT is a port open on the pty.
  39. ;;; TTYNAME is the name of the tty, e.g., "/dev/ttyk4"
  40. ;;;
  41. ;;; Scheme doesn't allow bidirectional ports, so the returned port
  42. ;;; is an input port -- however, the underlying file descriptor is
  43. ;;; opened read+write, and you can use DUP->OUTPORT to map it to
  44. ;;; corresponding output ports.
  45.  
  46. (define (open-pty)
  47.   (let ((next-pty (make-pty-generator)))
  48.     (let loop ()
  49.       (cond ((next-pty) =>
  50.          (lambda (pty-name)
  51.            (cond ((with-errno-handler ((errno packet) (else #f))
  52.                 (open-file pty-name open/read+write)) =>
  53.               (lambda (pty) ; Score!
  54.             (values pty (pty-name->tty-name pty-name))))
  55.  
  56.              (else (loop))))) ; Open failed; try another pty.
  57.  
  58.         (else (error "open-pty: could not open new pty"))))))
  59.  
  60. ;;; The following code may in fact be system dependent.
  61. ;;; If so, we'll move it out to the architecture specific directories.
  62.  
  63. ;;; Map between corresponding pty and tty filenames.
  64.  
  65. (define (pty/tty-name-mapper char)
  66.   (lambda (name)
  67.     (let ((ans (string-copy name)))
  68.       (string-set! ans 5 char)        ; Change X in "/dev/Xtyzz" to CHAR.
  69.       ans)))
  70.       
  71. (define pty-name->tty-name (pty/tty-name-mapper #\t)) ;/dev/ttyk3 -> /dev/ptyk3
  72. (define tty-name->pty-name (pty/tty-name-mapper #\p)) ;/dev/ptyk3 -> /dev/ttyk3
  73.  
  74.  
  75. ;;; Generator for the set of possible pty names.
  76.  
  77. (define (make-pty-generator)
  78.   (let* ((pattern (string-copy"/dev/ptyLN")) ; L=letter N=number
  79.      (l-pos 8)
  80.      (n-pos 9)
  81.  
  82. ;     (letters "pqrstuvwxyzPQRST")    ; From telnetd source in BSD4.4.
  83. ;     (numbers "0123456789abcdef")
  84.      (letters "pq")    ; From telnetd source in BSD4.4.
  85.      (numbers "0123456789abcdef")
  86.      (num-letters (string-length letters))
  87.      (num-numbers (string-length numbers))
  88.  
  89.      (l num-letters)    ; Generator's state vars. The value
  90.      (n 0))            ; of the last elt that was generated.
  91.                     ; (We count backwards to (0,0); n fastest.)
  92.     (lambda ()
  93.       (call-with-current-continuation
  94.         (lambda (abort)
  95.       (if (zero? n)
  96.           (if (zero? l) (abort #f)    ; No more.
  97.           (begin (set! l (- l 1))
  98.              (set! n (- num-numbers 1))
  99.              (string-set! pattern l-pos (string-ref letters l))))
  100.           (set! n (- n 1)))
  101.       (string-set! pattern n-pos (string-ref numbers n))
  102.       (string-copy pattern))))))
  103.